home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / dependent.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  51KB  |  1,563 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;; This file contains some of the system dependent code for CLX
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23. (export '(
  24.       default-error-handler
  25.       define-condition))
  26.  
  27. #+explorer
  28. (zwei:define-indentation event-case (1 1))
  29.  
  30. ;;; Number of seconds to wait for a reply to a server request
  31. (defparameter *reply-timeout* nil) 
  32.  
  33. #-(or clx-overlapping-arrays (not clx-little-endian))
  34. (progn
  35.   (defconstant *word-0* 0)
  36.   (defconstant *word-1* 1)
  37.  
  38.   (defconstant *long-0* 0)
  39.   (defconstant *long-1* 1)
  40.   (defconstant *long-2* 2)
  41.   (defconstant *long-3* 3))
  42.  
  43. #-(or clx-overlapping-arrays clx-little-endian)
  44. (progn
  45.   (defconstant *word-0* 1)
  46.   (defconstant *word-1* 0)
  47.  
  48.   (defconstant *long-0* 3)
  49.   (defconstant *long-1* 2)
  50.   (defconstant *long-2* 1)
  51.   (defconstant *long-3* 0))
  52.  
  53. ;;; Set some compiler-options for often used code
  54.  
  55. (eval-when (eval compile load)
  56.  
  57. (defconstant *buffer-speed* 3 "Speed compiler option for buffer code.")
  58. (defconstant *buffer-safety* 0 "Safety compiler option for buffer code.")
  59.  
  60. (defmacro declare-bufmac ()
  61.   `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
  62.  
  63. ;;; It's my impression that in lucid there's some way to make a declaration
  64. ;;; called fast-entry or something that causes a function to not do some
  65. ;;; checking on args. Sadly, we have no lucid manuals here.  If such a
  66. ;;; declaration is available, it would be a good idea to make it here when
  67. ;;; *buffer-speed* is 3 and *buffer-safety* is 0.
  68. (defmacro declare-buffun ()
  69.   `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
  70.  
  71. )
  72.  
  73. (proclaim '(inline card8->int8 int8->card8
  74.            card16->int16 int16->card16
  75.            card32->int32 int32->card32))
  76.  
  77. (defun card8->int8 (x)
  78.   (declare (type card8 x))
  79.   (declare-values int8)
  80.   (declare-buffun)
  81.   (the int8 (if (logbitp 7 x)
  82.         (the int8 (- x #x100))
  83.           x)))
  84.  
  85. (defun int8->card8 (x)
  86.   (declare (type int8 x))
  87.   (declare-values card8)
  88.   (declare-buffun)
  89.   (the card8 (ldb (byte 8 0) x)))
  90.  
  91. (defun card16->int16 (x)
  92.   (declare (type card16 x))
  93.   (declare-values int16)
  94.   (declare-buffun)
  95.   (the int16 (if (logbitp 15 x)
  96.          (the int8 (- x #x10000))
  97.          x)))
  98.  
  99. (defun int16->card16 (x)
  100.   (declare (type int16 x))
  101.   (declare-values card16)
  102.   (declare-buffun)
  103.   (the card16 (ldb (byte 16 0) x)))
  104.  
  105. #-genera
  106. (defun card32->int32 (x)
  107.   (declare (type card32 x))
  108.   (declare-values int32)
  109.   (declare-buffun)
  110.   (the int32 (if (logbitp 31 x)
  111.          (the int32 (- x #x100000000))
  112.          x)))
  113.  
  114. #+genera
  115. (defun card32->int32 (x)
  116.   (macrolet ((signify (x)
  117.            ;; 7.1 is defective
  118.            (if (= (sys:%logldb (byte 32 0) #x80000000) #x80000000)
  119.            `(if (logbitp 31 ,x)
  120.             (sys:%logdpb (ldb (byte 8 24) ,x) (byte 8 24) (ldb (byte 24 0) ,x))
  121.             ,x)
  122.            `(sys:%logldb (byte 32 0) ,x))))
  123.     (signify x)))
  124.  
  125. (defun int32->card32 (x)
  126.   (declare (type int32 x))
  127.   (declare-values card32)
  128.   (declare-buffun)
  129.   (the card32 (ldb (byte 32 0) x)))
  130.  
  131. (proclaim '(inline aref-card8 aset-card8 aref-int8 aset-int8))
  132.  
  133. (defun aref-card8 (a i)
  134.   (declare (type buffer-bytes a)
  135.        (type array-index i))
  136.   (declare-values card8)
  137.   (declare-buffun)
  138.   (the card8 (aref a i)))
  139.  
  140. (defun aset-card8 (v a i)
  141.   (declare (type card8 v)
  142.        (type buffer-bytes a)
  143.        (type array-index i))
  144.   (declare-buffun)
  145.   (setf (aref a i) v))
  146.  
  147. (defun aref-int8 (a i)
  148.   (declare (type buffer-bytes a)
  149.        (type array-index i))
  150.   (declare-values int8)
  151.   (declare-buffun)
  152.   (card8->int8 (aref a i)))
  153.  
  154. (defun aset-int8 (v a i)
  155.   (declare (type int8 v)
  156.        (type buffer-bytes a)
  157.        (type array-index i))
  158.   (declare-buffun)
  159.   (setf (aref a i) (int8->card8 v)))
  160.  
  161. #+clx-overlapping-arrays
  162. (proclaim '(inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29
  163.            aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))
  164.  
  165. #+(and clx-overlapping-arrays genera)
  166. (progn
  167.  
  168. (defun aref-card16 (a i)
  169.   (aref a i))
  170.  
  171. (defun aset-card16 (v a i)
  172.   (setf (aref a i) v))
  173.  
  174. (defun aref-int16 (a i)
  175.   (card16->int16 (aref a i)))
  176.  
  177. (defun aset-int16 (v a i)
  178.   (setf (aref a i) (int16->card16 v))
  179.   v)
  180.  
  181. (defun aref-card32 (a i)
  182.   (int32->card32 (aref a i)))
  183.  
  184. (defun aset-card32 (v a i)
  185.   (setf (aref a i) (card32->int32 v)))
  186.  
  187. (defun aref-int32 (a i) (aref a i))
  188.  
  189. (defun aset-int32 (v a i)
  190.   (setf (aref a i) v))
  191.  
  192. (defun aref-card29 (a i) (aref a i))
  193.  
  194. (defun aset-card29 (v a i)
  195.   (setf (aref a i) v))
  196.  
  197. )
  198.  
  199. #+(and clx-overlapping-arrays (or explorer lambda cadr))
  200. (progn
  201.  
  202. (defun aref-card16 (a i)
  203.   (aref a i))
  204.  
  205. (defun aset-card16 (v a i)
  206.   (setf (aref a i) v))
  207.  
  208. (defun aref-int16 (a i)
  209.   (card16->int16 (aref a i)))
  210.  
  211. (defun aset-int16 (v a i)
  212.   (setf (aref a i) (int16->card16 v))
  213.   v)
  214.  
  215. (defun aref-card32 (a i)
  216.   (aref a i))
  217.  
  218. (defun aset-card32 (v a i)
  219.   (setf (aref a i) v))
  220.  
  221. (defun aref-int32 (a i)
  222.   (card32->int32 (aref a i)))
  223.  
  224. (defun aset-int32 (v a i)
  225.   (setf (aref a i) (int32->card32 v))
  226.   v)
  227.  
  228. (defun aref-card29 (a i)
  229.   (aref a i))
  230.  
  231. (defun aset-card29 (v a i)
  232.   (setf (aref a i) v))
  233.  
  234. )
  235.  
  236. #+excl
  237. (progn
  238.   
  239.   (defun aref-card16 (a i)
  240.     (declare (type buffer-bytes a)
  241.          (type array-index i))
  242.     (declare-values card16)
  243.     (declare-buffun)
  244.     (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  245.                 :unsigned-word)))
  246.   
  247.   (defun aset-card16 (v a i)
  248.     (declare (type card16 v)
  249.          (type buffer-bytes a)
  250.          (type array-index i))
  251.     (declare-buffun)
  252.     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  253.               :unsigned-word) v))
  254.   
  255.   (defun aref-int16 (a i)
  256.     (declare (type buffer-bytes a)
  257.          (type array-index i))
  258.     (declare-values int16)
  259.     (declare-buffun)
  260.     (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  261.                :signed-word)))
  262.   
  263.   (defun aset-int16 (v a i)
  264.     (declare (type int16 v)
  265.          (type buffer-bytes a)
  266.          (type array-index i))
  267.     (declare-buffun)
  268.     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  269.               :signed-word) v))
  270.   
  271.   (defun aref-card32 (a i)
  272.     (declare (type buffer-bytes a)
  273.          (type array-index i))
  274.     (declare-values card32)
  275.     (declare-buffun)
  276.     (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  277.                 :unsigned-long)))
  278.     
  279.   (defun aset-card32 (v a i)
  280.     (declare (type card32 v)
  281.          (type buffer-bytes a)
  282.          (type array-index i))
  283.     (declare-buffun)
  284.     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  285.               :unsigned-long) v))
  286.  
  287.   (defun aref-int32 (a i)
  288.     (declare (type buffer-bytes a)
  289.          (type array-index i))
  290.     (declare-values int32)
  291.     (declare-buffun)
  292.     (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  293.                :signed-long)))
  294.     
  295.   (defun aset-int32 (v a i)
  296.     (declare (type int32 v)
  297.          (type buffer-bytes a)
  298.          (type array-index i))
  299.     (declare-buffun)
  300.     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  301.               :signed-long) v))
  302.  
  303.   (defun aref-card29 (a i)
  304.     ;; Do I need to mask off a few bits here?  XXX
  305.     (declare (type buffer-bytes a)
  306.          (type array-index i))
  307.     (declare-values card29)
  308.     (declare-buffun)
  309.     (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  310.                 :unsigned-long)))
  311.  
  312.   (defun aset-card29 (v a i)
  313.     (declare (type card29 v)
  314.          (type buffer-bytes a)
  315.          (type array-index i))
  316.     (declare-buffun)
  317.     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
  318.               :unsigned-long) v))
  319.  
  320. )
  321.  
  322. #-(or excl clx-overlapping-arrays)
  323. (progn
  324.  
  325. (defun aref-card16 (a i)
  326.   (declare (type buffer-bytes a)
  327.        (type array-index i))
  328.   (declare-values card16)
  329.   (declare-buffun)
  330.   (the card16
  331.        (logior (the card16
  332.             (ash (the card8 (aref a (index+ i *word-1*))) 8))
  333.            (the card8
  334.             (aref a (index+ i *word-0*))))))
  335.  
  336. (defun aset-card16 (v a i)
  337.   (declare (type card16 v)
  338.        (type buffer-bytes a)
  339.        (type array-index i))
  340.   (declare-buffun)
  341.   (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
  342.     (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
  343.   v)
  344.  
  345. (defun aref-int16 (a i)
  346.   (declare (type buffer-bytes a)
  347.        (type array-index i))
  348.   (declare-values int16)
  349.   (declare-buffun)
  350.   (the int16
  351.        (logior (the int16
  352.             (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8))
  353.            (the card8
  354.             (aref a (index+ i *word-0*))))))
  355.  
  356. (defun aset-int16 (v a i)
  357.   (declare (type int16 v)
  358.        (type buffer-bytes a)
  359.        (type array-index i))
  360.   (declare-buffun)
  361.   (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
  362.     (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
  363.   v)
  364.  
  365. (defun aref-card32 (a i)
  366.   (declare (type buffer-bytes a)
  367.        (type array-index i))
  368.   (declare-values card32)
  369.   (declare-buffun)
  370.   (the card32
  371.        (logior (the card32
  372.             (ash (the card8 (aref a (index+ i *long-3*))) 24))
  373.            (the card29
  374.             (ash (the card8 (aref a (index+ i *long-2*))) 16))
  375.            (the card16
  376.             (ash (the card8 (aref a (index+ i *long-1*))) 8))
  377.            (the card8
  378.             (aref a (index+ i *long-0*))))))
  379.  
  380. (defun aset-card32 (v a i)
  381.   (declare (type card32 v)
  382.        (type buffer-bytes a)
  383.        (type array-index i))
  384.   (declare-buffun)
  385.   (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
  386.     (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
  387.     (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
  388.     (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
  389.   v)
  390.  
  391. (defun aref-int32 (a i)
  392.   (declare (type buffer-bytes a)
  393.        (type array-index i))
  394.   (declare-values int32)
  395.   (declare-buffun)
  396.   (the int32
  397.        (logior (the int32
  398.             (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24))
  399.            (the card29
  400.             (ash (the card8 (aref a (index+ i *long-2*))) 16))
  401.            (the card16
  402.             (ash (the card8 (aref a (index+ i *long-1*))) 8))
  403.            (the card8
  404.             (aref a (index+ i *long-0*))))))
  405.  
  406. (defun aset-int32 (v a i)
  407.   (declare (type int32 v)
  408.        (type buffer-bytes a)
  409.        (type array-index i))
  410.   (declare-buffun)
  411.   (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
  412.     (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
  413.     (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
  414.     (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
  415.   v)
  416.  
  417. (defun aref-card29 (a i)
  418.   (declare (type buffer-bytes a)
  419.        (type array-index i))
  420.   (declare-values card29)
  421.   (declare-buffun)
  422.   (the card29
  423.        (logior (the card29
  424.             (ash (the card8 (aref a (index+ i *long-3*))) 24))
  425.            (the card29
  426.             (ash (the card8 (aref a (index+ i *long-2*))) 16))
  427.            (the card16
  428.             (ash (the card8 (aref a (index+ i *long-1*))) 8))
  429.            (the card8
  430.             (aref a (index+ i *long-0*))))))
  431.  
  432. (defun aset-card29 (v a i)
  433.   (declare (type card29 v)
  434.        (type buffer-bytes a)
  435.        (type array-index i))
  436.   (declare-buffun)
  437.   (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
  438.     (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
  439.     (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
  440.     (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
  441.   v)
  442.  
  443. )
  444.  
  445. (defsetf aref-card8 (a i) (v)
  446.   `(aset-card8 ,v ,a ,i))
  447.  
  448. (defsetf aref-int8 (a i) (v)
  449.   `(aset-int8 ,v ,a ,i))
  450.  
  451. (defsetf aref-card16 (a i) (v)
  452.   `(aset-card16 ,v ,a ,i))
  453.  
  454. (defsetf aref-int16 (a i) (v)
  455.   `(aset-int16 ,v ,a ,i))
  456.  
  457. (defsetf aref-card32 (a i) (v)
  458.   `(aset-card32 ,v ,a ,i))
  459.  
  460. (defsetf aref-int32 (a i) (v)
  461.   `(aset-int32 ,v ,a ,i))
  462.  
  463. (defsetf aref-card29 (a i) (v)
  464.   `(aset-card29 ,v ,a ,i))
  465.  
  466. ;;; Other random conversions
  467.  
  468. (defun rgb-val->card16 (value)
  469.   (declare (type float value))
  470.   (declare-buffun)
  471.   ;; Convert VALUE from float to card16
  472.   (the card16 (identity (truncate (the float value) #.(/ 1.0 #xffff)))))
  473.  
  474. (defun card16->rgb-val (value) 
  475.   (declare (type card16 value))
  476.   (declare-buffun)
  477.   ;; Convert VALUE from card16 to float
  478.   (the float (/ (the card16 value) #.(float #xffff))))
  479.  
  480. (defun radians->int16 (value)
  481.   ;; Short floats are good enough
  482.   (declare (type float value))
  483.   (declare-values int16)
  484.   (declare-buffun)
  485.   (the int16 (identity (round (* value 180.0s0 64.0s0) #.(coerce pi 'short-float)))))
  486.  
  487. (defun int16->radians (value)
  488.   ;; Short floats are good enough
  489.   (declare (type int16 value))
  490.   (declare-values short-float)
  491.   (declare-buffun)
  492.   (the short-float (* value #.(coerce (/ pi 180.0 64.0) 'short-float))))
  493.  
  494. ;;; Character transformation
  495.  
  496. ;;; This stuff transforms chars to ascii codes in card8's and back.
  497. ;;; You might have to hack it a little to get it to work for your machine.
  498.  
  499. (eval-when (eval compile)
  500. (defparameter *char-to-ascii-alist*
  501.           '#.`(#-lispm
  502.            ;; The normal ascii codes for the control characters.
  503.            ,@`((#\Return . 13)
  504.                (#\Linefeed . 10)
  505.                (#\Rubout . 127)
  506.                (#\Page . 12)
  507.                (#\Tab . 9)
  508.                (#\Backspace . 8)
  509.                (#\Newline . 10)
  510.                (#\Space . 32))
  511.            ;; One the lispm, #\Newline is #\Return, but we'd really like
  512.            ;; #\Newline to translate to ascii code 10, so we swap the
  513.            ;; Ascii codes for #\Return and #\Linefeed. We also provide
  514.            ;; mappings from the counterparts of these control characters
  515.            ;; so that the character mapping from the lisp machine
  516.            ;; character set to ascii is invertible.
  517.            #+lispm
  518.            ,@`((#\Return . 10)   (,(code-char  10) . ,(char-code #\Return))
  519.                (#\Linefeed . 13) (,(code-char  13) . ,(char-code #\Linefeed))
  520.                (#\Rubout . 127)  (,(code-char 127) . ,(char-code #\Rubout))
  521.                (#\Page . 12)     (,(code-char  12) . ,(char-code #\Page))
  522.                (#\Tab . 9)       (,(code-char   9) . ,(char-code #\Tab))
  523.                (#\Backspace . 8) (,(code-char   8) . ,(char-code #\Backspace))
  524.                (#\Newline . 10)  (,(code-char  10) . ,(char-code #\Newline))
  525.                (#\Space . 32)    (,(code-char  32) . ,(char-code #\Space)))
  526.            ;; The rest of the common lisp charater set with the normal
  527.            ;; ascii codes for them.
  528.            (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
  529.            (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
  530.            (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
  531.            (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
  532.            (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
  533.            (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
  534.            (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
  535.            (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
  536.            (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
  537.            (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
  538.            (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
  539.            (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
  540.            (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
  541.            (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
  542.            (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
  543.            (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
  544.            (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
  545.            (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
  546.            (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
  547.            (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
  548.            (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
  549.            (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
  550.            (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
  551.            (#\} . 125) (#\~ . 126)))
  552.  
  553.  
  554. (pushnew :clx-ascii *features*)
  555. (dolist (pair *char-to-ascii-alist*)
  556.   (when (not (= (char-code (car pair)) (cdr pair)))
  557.     (return (setq *features* (delete :clx-ascii *features*)))))
  558.  
  559. )
  560.  
  561. (proclaim '(inline char->card8 card8->char))
  562.  
  563. #-clx-ascii
  564. (progn
  565.   
  566. (defparameter *char-to-card8-translation-table*
  567.           '#.(let ((array (make-array
  568.                 (let ((max-char-code 255))
  569.                   (dolist (pair *char-to-ascii-alist*)
  570.                     (setq max-char-code
  571.                       (max max-char-code (char-code (car pair)))))
  572.                   (1+ max-char-code))
  573.                 :element-type 'card8)))
  574.            (dotimes (i (length array))
  575.              (setf (aref array i) (mod i 256)))
  576.            (dolist (pair *char-to-ascii-alist*)
  577.              (setf (aref array (char-code (car pair))) (cdr pair)))
  578.            array))
  579.  
  580. (defparameter *card8-to-char-translation-table*
  581.           '#.(let ((array (make-string 256)))
  582.            (dotimes (i (length array))
  583.              (setf (aref array i) (code-char (mod i 256))))
  584.            (dolist (pair *char-to-ascii-alist*)
  585.              (setf (aref array (cdr pair)) (car pair)))
  586.            array))
  587.  
  588. (defun char->card8 (char)
  589.   (declare (type string-char char))
  590.   (declare-buffun)
  591.   (the card8 (aref (the (simple-array card8 (*)) *char-to-card8-translation-table*)
  592.            (the array-index (char-code char)))))
  593.  
  594. (defun card8->char (card8)
  595.   (declare (type card8 card8))
  596.   (declare-buffun)
  597.   (the string-char (aref (the simple-string *card8-to-char-translation-table*) card8)))
  598.  
  599. (defun check-character-mapping-consistency ()
  600.   (dotimes (i 256)
  601.     (unless (= i (char->card8 (card8->char i)))
  602.       (warn "The card8->char mapping is not invertible through char->card8.  Info:~%~S"
  603.         (list i (card8->char i) (char->card8 (card8->char i))))
  604.       (return nil)))
  605.   (dotimes (i (length *char-to-card8-translation-table*))
  606.     (let ((char (code-char i)))
  607.       (unless (eql char (card8->char (char->card8 char)))
  608.     (warn "The char->card8 mapping is not invertible through card8->char.  Info:~%~S"
  609.           (list char (char->card8 char) (card8->char (char->card8 char))))
  610.     (return nil)))))
  611.  
  612. (check-character-mapping-consistency)
  613.  
  614. )
  615.  
  616. #+clx-ascii
  617. (progn
  618.  
  619. (defun char->card8 (char)
  620.   (declare (type string-char char))
  621.   (declare-buffun)
  622.   (the card8 (char-code char)))
  623.  
  624. (defun card8->char (card8)
  625.   (declare (type card8 card8))
  626.   (declare-buffun)
  627.   (the string-char (code-char card8)))
  628.  
  629. (eval-when (eval compile)
  630.   (setq *features* (delete :clx-ascii *features*)))
  631.  
  632. )
  633.  
  634.  
  635. ;;-----------------------------------------------------------------------------
  636. ;; Process Locking
  637. ;;
  638. ;;    Common-Lisp doesn't provide process locking primitives, so we define
  639. ;;    our own here, based on Zetalisp primitives.  Holding-Lock is very
  640. ;;    similar to with-lock on The TI Explorer, and a little more efficient
  641. ;;    than with-process-lock on a Symbolics.
  642.  
  643. #+excl
  644. (defun make-process-lock ()
  645.   (mp:make-process-lock))
  646.  
  647. #+imach
  648. (defun make-process-lock ()
  649.   (process:make-lock "CLX Lock" :recursive t))
  650.  
  651. #-(or excl imach)
  652. (defun make-process-lock ()
  653.   nil)
  654.  
  655. #+imach
  656. (defmacro holding-lock ((locator &optional whostate) &body body)
  657.   whostate
  658.   `(process:with-lock (,locator)
  659.      ,@body))
  660.  
  661. #+(and lispm (not imach))
  662. (defmacro holding-lock ((locator &optional whostate) &body body)
  663.   ; This macro is for use in a multi-process environment.
  664.   (let ((lock (gensym)) (have-lock (gensym)))
  665.     `(let* ((,lock (zl:locf ,locator))
  666.         (,have-lock (eq (car ,lock) sys:current-process)))
  667.        (unwind-protect 
  668.        (progn (unless ,have-lock
  669.             ;; Redundant, but saves time if not locked.
  670.             (or #+explorer
  671.             (si:%store-conditional ,lock nil sys:current-process)
  672.             #-explorer
  673.             (sys:store-conditional ,lock nil sys:current-process)
  674.             (sys:process-lock ,lock ,@(when whostate `(nil ,whostate)))))
  675.           ,@body)
  676.      (unless ,have-lock
  677.        #+explorer
  678.        (si:%store-conditional ,lock sys:current-process nil)
  679.        #-explorer
  680.        (sys:store-conditional ,lock sys:current-process nil))))))
  681.  
  682. #+excl
  683. ;;
  684. ;; Note that there is a special hack here.  If the current process is nil it
  685. ;; means we're running in the scheduler stack group, which means in turn that
  686. ;; we're running a process wait function.  This wait functions should *always*
  687. ;; be: (event-listen display 0).  So if we are running in the scheduler and the
  688. ;; lock isn't already being held just run the body without trying to grab the
  689. ;; lock.  If the lock *is* already being held we have to throw out of the
  690. ;; event-listen.
  691. ;;
  692. (defmacro holding-lock ((locator &optional whostate) &body body)
  693.   ;; This macro is for use in a multi-process environment.
  694.   (let ((lock (gensym)) (curproc (gensym)) (locker (gensym))
  695.     (without-interrupts-state (gensym)))
  696.     
  697.     `(let* ((,without-interrupts-state excl::*without-interrupts*)
  698.         (excl::*without-interrupts* t)
  699.         (,lock ,locator)
  700.         (,curproc mp:*current-process*) ; nil if in scheduler (wait fun)
  701.         (,locker (mp:process-lock-locker ,lock)))
  702.        (declare (special *inside-event-listen-catch*))
  703.        
  704.        (unwind-protect
  705.         (progn 
  706.           (if (and (null ,curproc) ,locker)
  707.           (if (and (boundp '*inside-event-listen-catch*)
  708.                *inside-event-listen-catch*)
  709.               (throw 'event-listen :would-block)
  710.             (error "The only CLX function call allowed from a process wait \
  711.        function is event-listen with timeout 0.")))
  712.           (excl:if* (eq ,locker ,curproc)
  713.          then
  714.               (setq ,locker nil)
  715.          else
  716.               (setq ,locker ,curproc)
  717.               (mp:process-lock ,lock ,curproc
  718.                        ,@(when whostate `(,whostate))))
  719.           (setq excl::*without-interrupts* ,without-interrupts-state)
  720.           ,@body)
  721.      (if (and ,curproc (eq ,locker ,curproc))
  722.          (mp:process-unlock ,lock ,curproc))))))
  723.  
  724. ;; If you're not sharing DISPLAY objects within a multi-processing
  725. ;; shared-memory environment, this is sufficient
  726. #-(or lispm excl)
  727. (defmacro holding-lock ((locator &optional whostate) &body body)
  728.   locator whostate ;; not used
  729.   `(progn ,@body))
  730.  
  731. #+(and lispm (not imach))
  732. (defmacro atomic-push (item reference)
  733.   `(sys:without-interrupts (push ,item ,reference)))
  734.  
  735. #+(and lispm (not imach))
  736. (defmacro atomic-pop (list)
  737.   `(sys:without-interrupts (pop ,list)))
  738.  
  739. #+imach
  740. (defmacro atomic-push (item reference)
  741.   `(process:atomic-push ,item ,reference))
  742.  
  743. #+imach
  744. (defmacro atomic-pop (reference)
  745.   `(process:atomic-pop ,reference))
  746.  
  747. ;; If you don't have multi-processing or push is atomic, this is sufficient
  748. #-lispm
  749. (defmacro atomic-push (item reference)
  750.   `(push ,item ,reference))
  751.  
  752. ;; If you don't have multi-processing or pop is atomic, this is sufficient
  753. #-lispm
  754. (defmacro atomic-pop (list)
  755.   `(pop ,list))
  756.  
  757. #+excl
  758. (defvar *inside-event-listen-catch* nil)
  759.  
  760. #+excl
  761. (defmacro wrap-event-listen (form &body body)
  762.   ;; If we are running a process wait function (in the scheduler stack group)
  763.   ;; and the input lock is held by another process, return nil.
  764.   `(let ((*inside-event-listen-catch* t))
  765.      (unless (eq :would-block (catch 'event-listen ,form))
  766.        . ,body)))
  767.  
  768. #-excl
  769. (defmacro wrap-event-listen (form &body body)
  770.   `(progn ,form . ,body))
  771.  
  772. ;;;-----------------------------------------------------------------------------
  773. ;;; IO Error Recovery
  774. ;;;    All I/O operations are done within a WRAP-BUF-OUTPUT macro.
  775. ;;;    It prevents multiple mindless errors when the network craters.
  776. ;;;
  777. #+comment ;; #+lispm
  778. (defmacro wrap-buf-output (buffer &body body)
  779.   ;; Error recovery wrapper
  780.   `(unless (buffer-dead ,buffer)
  781.      (sys:condition-case ()
  782.      (progn ,@body)
  783.        (sys:network-error (setf (buffer-dead ,buffer) t)))))
  784.  
  785. ;;#-lispm
  786. (defmacro wrap-buf-output (buffer &body body)
  787.   ;; Error recovery wrapper
  788.   `(unless (buffer-dead ,buffer)
  789.      ,@body))
  790.  
  791. ;;;-----------------------------------------------------------------------------
  792. ;;; System dependent IO primitives
  793. ;;;    Functions for opening, reading writing forcing-output and closing 
  794. ;;;    the stream to the server.
  795. ;;;-----------------------------------------------------------------------------
  796.  
  797. ;;; open-x-stream - create a stream for communicating to the appropriate X
  798. ;;; server
  799.  
  800. #-(or explorer genera lucid kcl excl)
  801. (defun open-x-stream (host display protocol)
  802.   host display protocol ;; unused
  803.   (error "OPEN-X-STREAM not implemented yet."))
  804.  
  805. #+genera
  806. (progn
  807.  
  808. ;;; TCP and DNA are both layered products, so try to work with either one.
  809.  
  810. (when (fboundp 'tcp:add-tcp-port-for-protocol)
  811.   (tcp:add-tcp-port-for-protocol :x-window-system 6000))
  812.  
  813. (when (fboundp 'dna:add-dna-contact-id-for-protocol)
  814.   (dna:add-dna-contact-id-for-protocol :x-window-system "X0"))
  815.  
  816. (net:define-protocol :x-window-system (:x-window-system :byte-stream)
  817.   (:invoke-with-stream ((stream :characters nil :ascii-translation nil))
  818.     stream))
  819. )
  820.  
  821. #+genera
  822. (defun open-x-stream (host display protocol)
  823.   (setf host (net:parse-host host))
  824.   ;; If PROTOCOL is NIL (the default), we use the generic network system to choose a network
  825.   ;; protocol. Since the GNS has no way to communicate the display number, this only works for
  826.   ;; display 0.  For other displays, we blindly default to TCP.
  827.   ;;
  828.   ;; To take advantage of this, add a service triple to the service host such as:
  829.   ;;   X-WINDOW-SYSTEM TCP X-WINDOW-SYSTEM
  830.   ;; or
  831.   ;;   X-WINDOW-SYSTEM DNA X-WINDOW-SYSTEM
  832.   (when (and (null protocol) (zerop display))
  833.     (return-from open-x-stream
  834.       (let ((neti:*invoke-service-automatic-retry* t))
  835.     (net:invoke-service-on-host :x-window-system host))))
  836.   (ccase protocol
  837.     ((:tcp nil)
  838.      (tcp:open-tcp-stream host (+ *x-tcp-port* display) nil
  839.               :direction :io
  840.               :characters nil
  841.               :ascii-translation nil))
  842.     ((:dna)
  843.      (dna:open-dna-bidirectional-stream host (format nil "X~D" display)
  844.                     :characters nil :ascii-translation nil))))
  845.  
  846. #+explorer
  847. (defun open-x-stream (host display protocol)
  848.   protocol ;; unused
  849.   (ip:open-stream host
  850.           :remote-port (+ *x-tcp-port* display)
  851.           :direction :bidirectional
  852.           :characters t
  853.           :timeout-after-open nil))
  854.  
  855. #+lucid
  856. (defun open-x-stream (host display protocol)
  857.   protocol ;; unused
  858.   (let ((fd (connect-to-server host display)))
  859.     (when (minusp fd)
  860.       (error "Failed to connect to server: ~A ~D" host display))
  861.     (user::make-lisp-stream :input-handle fd
  862.                 :output-handle fd
  863.                 :element-type 'unsigned-byte
  864.                 :stream-type :ephemeral)))
  865.  
  866. #+kcl
  867. (defun open-x-stream (host display protocol)
  868.   protocol ;; unused
  869.   (let ((stream (tcp:open-tcp-stream host (+ *x-tcp-port* display))))
  870.     (if (streamp stream)
  871.     stream
  872.       (error "Cannot connect to server: ~A:~D" host display))))
  873.  
  874. #+excl
  875. (defun open-x-stream (host display protocol)
  876.   (declare (ignore protocol));; unused
  877.   (let ((fd (connect-to-server host display))
  878.     stm)
  879.     (when (minusp fd)
  880.       (error "Failed to connect to server: ~A ~D" host display))
  881.     (setf stm (excl::make-vanilla-stream))
  882.     (excl::set-stream-fields
  883.      stm
  884.      excl::_sm_type :X-socket-stream
  885.      excl::_sm_flags #.(+ (comp:mdparam 'comp::md-stream-flag-input-p)
  886.               (comp:mdparam 'comp::md-stream-flag-output-p))
  887.      excl::_sm_fio-name fd)
  888.     stm))
  889.  
  890. ;;; buffer-read-default - read data from the X stream
  891.  
  892. #+(or genera explorer)
  893. (defun buffer-read-default (display vector start end timeout)
  894.   ;; returns non-NIL if EOF encountered
  895.   ;; Returns :TIMEOUT when timeout exceeded
  896.   (declare (type display display)
  897.        (type buffer-bytes vector)
  898.        (type array-index start end)
  899.        (type (or null number) timeout))
  900.   (declare-buffun)
  901.   (let ((stream (display-input-stream display))
  902.     (eofp nil))
  903.     (when timeout
  904.       (unless (sys:process-wait-with-timeout
  905.           "X Server"
  906.           (round (* timeout 60.)) stream :listen)
  907.     (setq eofp :timeout)))
  908.     (unless eofp
  909.       (multiple-value-setq (nil eofp)
  910.     (funcall stream :string-in nil vector start end)))
  911.     eofp))
  912.  
  913. #+excl
  914. ;;
  915. ;; This is used so an 'eq' test may be used to find out whether or not we can
  916. ;; safely throw this process out of the CLX read loop.
  917. ;;
  918. (defparameter *read-whostate* "blocked on read from X server")
  919.  
  920. #+excl
  921. (defun listen-fd (fd howmany)
  922.   (declare (type fixnum fd howmany))
  923.   (declare-buffun)
  924.   (case (c-check-bytes fd howmany)
  925.     (0 nil)
  926.     (1 t)
  927.     ;; Error -- let it be detected by the read.
  928.     (-1 t)))
  929.  
  930. #+excl
  931. (defun buffer-read-default (display vector start end timeout)
  932.   (declare (type display display)
  933.        (type buffer-bytes vector)
  934.        (type array-index start end)
  935.        (type (or null number) timeout))
  936.   (declare-buffun)
  937.   (let ((howmany (- end start))
  938.     (fd (excl::_sm_fio-name (display-input-stream display))))
  939.     
  940.     ;; If there are enough available just read them.
  941.     (cond ((listen-fd fd howmany)
  942.        (minusp (c-read-bytes fd vector start end)))
  943.       
  944.        ;; If there aren't enough and timeout == 0, timeout.
  945.       ((and timeout (zerop timeout))
  946.        :timeout)
  947.       
  948.        ;; Otherwise if the scheduler is running let it handle timeouts
  949.       ((excl::scheduler-running-p)
  950.        (unwind-protect
  951.         (progn
  952.           (mp::mpwatchfor fd)
  953.           (if (null timeout)
  954.               (mp:process-wait *read-whostate*
  955.                        #'listen-fd fd howmany)
  956.             ;; Otherwise we have a timeout to wait for.
  957.             ;; This doesn't work under 2.0.
  958.             #+allegro
  959.             (if (eql (mp:process-wait-with-timeout
  960.                   *read-whostate* timeout
  961.                   #'listen-fd fd howmany)
  962.                  'mp::with-timeout-internal)
  963.             (return-from buffer-read-default :timeout))
  964.             #-allegro
  965.             (mp:process-wait *read-whostate*
  966.                      #'listen-fd fd howmany)))
  967.          (mp::mpunwatchfor fd))
  968.        ;; Now the read will succeed.
  969.        (minusp (c-read-bytes fd vector start end)))
  970.       
  971.       ;; Otherwise we have to handle timeouts by hand, and call a special
  972.        ;; c read function that will return on interrupt.
  973.       (t
  974.        (if (null timeout)
  975.            (do ((status (c-read-bytes-interruptible fd vector start end)
  976.                 (c-read-bytes-interruptible fd vector start end)))
  977.            ((null (eql status -2)) (minusp status)))
  978.          (dotimes (i (round timeout) :timeout)
  979.            (if (null (listen-fd fd howmany))
  980.            (sleep 1)
  981.          (return-from buffer-read-default
  982.            (minusp
  983.              (c-read-bytes fd vector start end))))))))))
  984.  
  985. ;;; WARNING:
  986. ;;;    CLX performance will suffer if your lisp uses read-byte for
  987. ;;;    receiving all data from the X Window System server.
  988. ;;;    You are encouraged to write a specialized version of
  989. ;;;    buffer-read-default that does block transfers.
  990. #-(or genera explorer excl)
  991. (defmacro CL-read-bytes (stream vector start end)
  992.   `(do* ((i ,start (index+ i 1))
  993.      (c nil))
  994.     ((index>= i ,end) nil)
  995.      (declare (type array-index i)
  996.           (type (or null card8) c))
  997.      (setq c (read-byte ,stream nil nil))
  998.      (if c
  999.      (setf (aref ,vector i) c)
  1000.      (return t))))
  1001.  
  1002. ;; Poll for input every *buffer-read-polling-time* SECONDS.
  1003. #-(or genera explorer excl)
  1004. (defparameter *buffer-read-polling-time* 0.5)
  1005.  
  1006. #-(or genera explorer excl)
  1007. (defun buffer-read-default (display vector start end timeout)
  1008.   (declare (type display display)
  1009.        (type buffer-bytes vector)
  1010.        (type array-index start end)
  1011.        (type (or null (rational 0 *) (float 0.0 *)) timeout))
  1012.   (declare-buffun)
  1013.   (let ((stream (display-input-stream display)))
  1014.     (declare (type stream stream))
  1015.     (cond ((or (null timeout)            ; timeout = NIL
  1016.            (listen stream))            ; OR input waiting
  1017.        (cl-read-bytes stream vector start end))
  1018.       ((zerop timeout)            ; timeout = 0 
  1019.        :timeout)                ; no input (we listened above)
  1020.       (t                    ; timeout > 0, so poll until time is up.
  1021.        (multiple-value-bind (npoll fraction)
  1022.            (truncate timeout *buffer-read-polling-time*)
  1023.          (if (or (listen stream)        ; listen first
  1024.              (dotimes (i npoll)        ; Sleep for a time, then listen again
  1025.                (sleep *buffer-read-polling-time*)
  1026.                (when (listen stream) (return t)))
  1027.              (when (plusp fraction)
  1028.                (sleep fraction)        ; Sleep a fraction of a second
  1029.                (listen stream)))    ; and listen one last time
  1030.          (cl-read-bytes stream vector start end)
  1031.          :timeout))))))
  1032.  
  1033. ;;; buffer-write--default - write data to the X stream
  1034.  
  1035. #+(or genera explorer)
  1036. (defun buffer-write-default (vector display start end)
  1037.   ;; The default buffer write function for use with common-lisp streams
  1038.   (declare (type buffer-bytes vector)
  1039.        (type display display)
  1040.        (type array-index start end))
  1041.   (declare-buffun)
  1042.   (write-string vector (display-output-stream display) :start start :end end))
  1043.  
  1044. #+excl
  1045. (defun buffer-write-default (vector display start end)
  1046.   (declare (type buffer-bytes vector)
  1047.        (type display display)
  1048.        (type array-index start end))
  1049.   (declare-buffun)
  1050.   (if (minusp (c-write-bytes (excl::_sm_fio-name (display-output-stream display))
  1051.                  vector start end))
  1052.       (error "X write failed:  socket dead!")))
  1053.  
  1054. ;;; WARNING:
  1055. ;;;    CLX performance will be severely degraded if your lisp uses
  1056. ;;;    write-byte to send all data to the X Window System server.
  1057. ;;;    You are STRONGLY encouraged to write a specialized version
  1058. ;;;    of buffer-write-default that does block transfers.
  1059.  
  1060. #-(or genera explorer excl)
  1061. (defun buffer-write-default (vector display start end)
  1062.   ;; The default buffer write function for use with common-lisp streams
  1063.   (declare (type buffer-bytes vector)
  1064.        (type display display)
  1065.        (type array-index start end))
  1066.   (declare-buffun)
  1067.   (with-vector (vector buffer-bytes)
  1068.     (do ((stream (display-output-stream display))
  1069.      (index start (index+ index 1)))
  1070.     ((index>= index end))
  1071.       (declare (type stream stream)
  1072.            (type array-index index))
  1073.       (write-byte (aref vector index) stream))))
  1074.  
  1075. ;;; buffer-force-output-default - force output to the X stream
  1076.  
  1077. #+excl
  1078. (defun buffer-force-output-default (display)
  1079.   ;; The default buffer force-output function for use with common-lisp streams
  1080.   (declare (type display display))
  1081.   (if (minusp
  1082.     (c-flush-bytes (excl::_sm_fio-name (display-output-stream display))))
  1083.       (error "X write failed:  socket dead!")))
  1084.  
  1085. #-excl
  1086. (defun buffer-force-output-default (display)
  1087.   ;; The default buffer force-output function for use with common-lisp streams
  1088.   (declare (type display display))
  1089.   (force-output (display-output-stream display)))
  1090.  
  1091. ;;; buffer-close-default - close the X stream
  1092.  
  1093.  
  1094. #+excl
  1095. (defun buffer-close-default (display &key abort)
  1096.   ;; The default buffer close function for use with common-lisp streams
  1097.   (declare (type display display))
  1098.   (declare-buffun)
  1099.   (let ((stream (display-output-stream display)))
  1100.     (excl::filesys-checking-close (excl::_sm_fio-name stream))
  1101.     (setf (excl::sm_flags stream) (logior (excl::sm_flags stream) #.(comp::mdparam 'comp::md-stream-flag-closed)))
  1102.     (excl::st-close-down-stream stream)))
  1103.  
  1104. #-excl
  1105. (defun buffer-close-default (display &key abort)
  1106.   ;; The default buffer close function for use with common-lisp streams
  1107.   (declare (type display display))
  1108.   (declare-buffun)
  1109.   (close (display-output-stream display) :abort abort))
  1110.  
  1111. ;;;-----------------------------------------------------------------------------
  1112. ;;; System dependent speed hacks
  1113. ;;;-----------------------------------------------------------------------------
  1114.  
  1115. ;;
  1116. ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature.
  1117. ;; If your lisp doesn't have stack-lists, and you're worried about
  1118. ;; consing garbage, you may want to re-write this to allocate and
  1119. ;; initialize lists from a resource.
  1120. ;;
  1121. #+lispm
  1122. (defmacro with-stack-list ((var &rest elements) &body body)
  1123.   `(sys:with-stack-list (,var ,@elements) ,@body))
  1124.  
  1125. #+lispm
  1126. (defmacro with-stack-list* ((var &rest elements) &body body)
  1127.   `(sys:with-stack-list* (,var ,@elements) ,@body))
  1128.  
  1129. #-lispm
  1130. (defmacro with-stack-list ((var &rest elements) &body body)
  1131.   ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
  1132.   ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
  1133.   ;; except that the list produced by MAPCAR resides on the stack and
  1134.   ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
  1135.   `(let ((,var (list ,@elements))) ,@body))
  1136.  
  1137. #-lispm
  1138. (defmacro with-stack-list* ((var &rest elements) &body body)
  1139.   ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
  1140.   ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
  1141.   ;; except that the list produced by MAPCAR resides on the stack and
  1142.   ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
  1143.   `(let ((,var (list* ,@elements))) ,@body))
  1144.  
  1145. (proclaim '(inline buffer-replace))
  1146.  
  1147. #+lispm
  1148. (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
  1149.   (declare (type vector buf1 buf2)
  1150.        (type array-index start1 end1 start2))
  1151.   (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1))
  1152.  
  1153. #+excl
  1154. (defun buffer-replace (target-sequence source-sequence target-start
  1155.                        target-end &optional (source-start 0))
  1156.   (declare (type buffer-bytes target-sequence source-sequence)
  1157.        (type array-index target-start target-end source-start)
  1158.        (optimize (speed 3) (safety 0)))
  1159.   
  1160.   (let ((source-end (length source-sequence)))
  1161.     (declare (type array-index source-end))
  1162.     
  1163.     (excl::if* (and (eq target-sequence source-sequence)
  1164.             (> target-start source-start))
  1165.        then (let ((nelts (min (- target-end target-start)
  1166.                   (- source-end source-start))))
  1167.           (do ((target-index (+ target-start nelts -1) (1- target-index))
  1168.            (source-index (+ source-start nelts -1) (1- source-index)))
  1169.           ((= target-index (1- target-start)) target-sequence)
  1170.         (declare (type array-index target-index source-index))
  1171.         
  1172.         (setf (aref target-sequence target-index)
  1173.           (aref source-sequence source-index))))
  1174.        else (do ((target-index target-start (1+ target-index))
  1175.          (source-index source-start (1+ source-index)))
  1176.         ((or (= target-index target-end) (= source-index source-end))
  1177.          target-sequence)
  1178.           (declare (type array-index target-index source-index))
  1179.  
  1180.           (setf (aref target-sequence target-index)
  1181.         (aref source-sequence source-index))))))
  1182.  
  1183. #+(and clx-overlapping-arrays (not (or lispm excl)))
  1184. (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
  1185.   (declare (type vector buf1 buf2)
  1186.        (type array-index start1 end1 start2))
  1187.   (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
  1188.  
  1189. #-(or lispm excl clx-overlapping-arrays)
  1190. (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
  1191.   (declare (type buffer-bytes buf1 buf2)
  1192.        (type array-index start1 end1 start2))
  1193.   (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
  1194.  
  1195. #+ti
  1196. (defun with-location-bindings (sys:"e bindings &rest body)
  1197.   (do ((bindings bindings (cdr bindings)))
  1198.       ((null bindings)
  1199.        (sys:eval-body-as-progn body))
  1200.     (sys:bind (sys:*eval `(sys:locf ,(caar bindings)))
  1201.           (sys:*eval (cadar bindings)))))
  1202.  
  1203. #+ti
  1204. (compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form)
  1205.   (let ((bindings (cadr form))
  1206.     (body (cddr form)))
  1207.     `(let ()
  1208.        ,@(loop for (accessor value) in bindings
  1209.            collect `(si:bind (si:locf ,accessor) ,value))
  1210.        ,@body)))
  1211.  
  1212. #+(and lispm (not ti))
  1213. (defmacro with-location-bindings (bindings &body body)
  1214.   `(sys:letf* ,bindings ,@body))
  1215.  
  1216. #+lispm
  1217. (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
  1218.                   &body body)
  1219.   ;; don't use svref on LHS because Symbolics didn't define locf for it
  1220.   (let* ((local-state (gensym))
  1221.      (bindings `(((aref ,local-state ,ts-index) 0))))    ; will become zero anyway
  1222.     (dolist (index indexes)
  1223.       (push `((aref ,local-state ,index) (svref ,saved-state ,index))
  1224.         bindings))
  1225.     `(let ((,local-state (gcontext-local-state ,gc)))
  1226.        (declare (type gcontext-state ,local-state))
  1227.        (unwind-protect
  1228.        (with-location-bindings ,bindings
  1229.          ,@body)
  1230.      (setf (svref ,local-state ,ts-index) 0)
  1231.      (when ,temp-gc
  1232.        (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
  1233.      (deallocate-gcontext-state ,saved-state)))))
  1234.  
  1235. #-lispm
  1236. (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
  1237.                   &body body)
  1238.   (let ((local-state (gensym))
  1239.     (resets nil))
  1240.     (dolist (index indexes)
  1241.       (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index))
  1242.         resets))
  1243.     `(unwind-protect
  1244.      (progn
  1245.        ,@body)
  1246.        (let ((,local-state (gcontext-local-state ,gc)))
  1247.      (declare (type gcontext-state ,local-state))
  1248.      ,@resets
  1249.      (setf (svref ,local-state ,ts-index) 0))
  1250.        (when ,temp-gc
  1251.      (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
  1252.        (deallocate-gcontext-state ,saved-state))))
  1253.  
  1254. ;;; -----------------------------------------------------------------------------
  1255. ;;; How error detection should CLX do?
  1256. ;;; Several levels are possible:
  1257. ;;;
  1258. ;;; 1. Do the equivalent of check-type on every argument.
  1259. ;;; 
  1260. ;;; 2. Simply report TYPE-ERROR.  This eliminates overhead of all the format
  1261. ;;;    strings generated by check-type.
  1262. ;;; 
  1263. ;;; 3. Do error checking only on arguments that are likely to have errors
  1264. ;;;    (like keyword names)
  1265. ;;; 
  1266. ;;; 4. Do error checking only where not doing so may dammage the envirnment
  1267. ;;;    on a non-tagged machine (i.e. when storing into a structure that has
  1268. ;;;    been passed in)
  1269. ;;; 
  1270. ;;; 5. No extra error detection code.  On lispm's, ASET may barf trying to
  1271. ;;;    store a non-integer into a number array. 
  1272. ;;; 
  1273. ;;; How extensive should the error checking be?  For example, if the server
  1274. ;;; expects a CARD16, is is sufficient for CLX to check for integer, or
  1275. ;;; should it also check for non-negative and less than 65536?
  1276. ;;;-----------------------------------------------------------------------------
  1277.  
  1278. ;; The *TYPE-CHECK?* constant controls how much error checking is done.
  1279. ;; Possible values are:
  1280. ;;    NIL      - Don't do any error checking
  1281. ;;    t        - Do the equivalent of checktype on every argument
  1282. ;;    :minimal - Do error checking only where errors are likely
  1283.  
  1284. ;;; This controls macro expansion, and isn't changable at run-time You will
  1285. ;;; probably want to set this to nil if you want good performance at
  1286. ;;; production time.
  1287. (defconstant *type-check?* t)
  1288.  
  1289. ;; TYPE? is used to allow the code to do error checking at a different level from
  1290. ;; the declarations.  It also does some optimizations for systems that don't have
  1291. ;; good compiler support for TYPEP.  The definitions for CARD32, CARD16, INT16, etc.
  1292. ;; include range checks.  You can modify TYPE? to do less extensive checking
  1293. ;; for these types if you desire.
  1294.  
  1295. (defmacro type? (object type)
  1296.   (if (not (constantp type))
  1297.       `(typep ,object ,type)
  1298.     (progn
  1299.       (setq type (eval type))
  1300.       #+explorer
  1301.       (if *type-check?*
  1302.       `(locally (declare (optimize safety)) (typep ,object ',type))
  1303.     `(typep ,object ',type))
  1304.       #-explorer
  1305.       (let ((predicate (assoc type
  1306.                   '((drawable drawable-p) (window window-p) (pixmap pixmap-p)
  1307.                 (cursor cursor-p) (font font-p)
  1308.                 (gcontext gcontext-p) (colormap colormap-p)
  1309.                 (null null) (integer integerp)))))
  1310.     (if predicate
  1311.         `(,(second predicate) ,object)
  1312.       (if *type-check?*
  1313.           `(locally (declare (optimize safety)) (typep ,object ',type))
  1314.         `(typep ,object ',type)))))))
  1315.  
  1316. ;; X-TYPE-ERROR is the function called for type errors.
  1317. ;; If you want lots of checking, but are concerned about code size,
  1318. ;; this can be made into a macro that ignores some parameters.
  1319.  
  1320. (defun x-type-error (object type &optional error-string)
  1321.   (x-error 'type-error :object object :type type :type-string error-string))
  1322.  
  1323. ;;-------------------------------------------------------------------------------
  1324. ;; Error handlers
  1325. ;;    Hack up KMP error signaling using zetalisp until the real thing comes along
  1326. ;;-------------------------------------------------------------------------------
  1327.  
  1328. (defun default-error-handler (display error-key &rest key-vals)
  1329.   ; The default display-error-handler.
  1330.   ; It signals the conditions listed in the DISPLAY file
  1331.   display
  1332.   (apply 'x-error error-key :display display :error-key error-key key-vals))
  1333.  
  1334. #+lispm
  1335. (defun x-error (condition &rest keyargs)
  1336.   (apply #'sys:signal condition keyargs))
  1337.  
  1338. #+lispm
  1339. (defun x-cerror (proceed-format-string condition &rest keyargs)
  1340.   (sys:signal (apply #'zl:make-condition condition keyargs)
  1341.           :proceed-types proceed-format-string))
  1342.  
  1343. #-lispm
  1344. (defun x-error (condition &rest keyargs)
  1345.   (error "X-Error: ~a"
  1346.      (princ-to-string (apply #'make-condition condition keyargs))))
  1347.  
  1348. #-lispm
  1349. (defun x-cerror (proceed-format-string condition &rest keyargs)
  1350.   (cerror proceed-format-string "X-Error: ~a"
  1351.      (princ-to-string (apply #'make-condition condition keyargs))))
  1352.  
  1353. ;; version 15 of Pitman error handling defines the syntax for define-condition to be:
  1354. ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*]
  1355. ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)
  1356. ;; or (:report exp)
  1357.  
  1358. #+lispm
  1359. (defmacro define-condition (name parents &body options)
  1360.   (let ((slots (pop options))
  1361.     (documentation nil)
  1362.     (conc-name (concatenate 'string (string name) "-"))           
  1363.     (reporter nil))
  1364.     (dolist (item options)
  1365.       (ecase (first item)
  1366.     (:documentation (setq documentation (second item)))
  1367.     (:conc-name (setq conc-name (string (second item))))
  1368.     (:report (setq reporter (second item)))))
  1369.     `(within-definition (,name define-condition)
  1370.        (zl:defflavor ,name ,slots ,parents
  1371.      :initable-instance-variables
  1372.      #-genera
  1373.      (:accessor-prefix ,conc-name)
  1374.      #+genera
  1375.      (:conc-name ,conc-name)
  1376.      #-genera
  1377.      (:outside-accessible-instance-variables ,@slots)
  1378.      #+genera
  1379.      (:readable-instance-variables ,@slots))
  1380.        ,(when reporter ;; when no reporter, parent's is inherited
  1381.       `(zl:defmethod #-genera (,name :report)
  1382.                      #+genera (:report ,name) (stream)
  1383.           ,(if (stringp reporter)
  1384.            `(write-string ,reporter stream)
  1385.          `(,reporter global:self stream))
  1386.           global:self))
  1387.        ,(when documentation
  1388.       `(setf (documentation name 'type) ,documentation))
  1389.        ',name)))
  1390.  
  1391. #+lispm
  1392. (zl:defflavor x-error () (global:error))
  1393.  
  1394. #-lispm
  1395. (defstruct x-error
  1396.   report-function)
  1397.  
  1398. #-lispm
  1399. (defun reporter-for-condition (name)
  1400.   (xintern "." name '-reporter.))
  1401.  
  1402. #-lispm
  1403. (defmacro define-condition (name parents &body options)
  1404.   ;; Define a structure that when printed displays an error message
  1405.   (let ((slots (pop options))
  1406.     (documentation nil)
  1407.     (conc-name (concatenate 'string (string name) "-"))           
  1408.     (reporter nil)
  1409.     (condition (gensym))
  1410.     (stream (gensym))
  1411.     (report-function (reporter-for-condition name)))
  1412.     (dolist (item options)
  1413.       (ecase (first item)
  1414.     (:documentation (setq documentation (second item)))
  1415.     (:conc-name (setq conc-name (string (second item))))
  1416.     (:report (setq reporter (second item)))))
  1417.     (unless reporter (setq report-function (reporter-for-condition (car parents))))
  1418.     `(within-definition (,name define-condition)
  1419.        (defstruct (,name (:conc-name ,(intern conc-name))
  1420.                  (:print-function condition-print)
  1421.              (:include ,(car parents) (report-function ',report-function)))
  1422.      ,@slots)
  1423.        ,(when documentation
  1424.       `(setf (documentation name 'type) ,documentation))
  1425.        ,(when reporter
  1426.       `(defun ,report-function (,condition ,stream)
  1427.          ,(if (stringp reporter)
  1428.           `(write-string ,reporter ,stream)
  1429.         `(,reporter ,condition ,stream))
  1430.          ,condition))
  1431.        ',name)))
  1432.  
  1433. #-lispm
  1434. (defun condition-print (condition stream depth)
  1435.   (declare (type x-error condition)
  1436.        (type stream stream)
  1437.        (ignore depth))
  1438.   (if *print-escape*
  1439.       (format stream "#<~a>" (type-of condition))
  1440.     (funcall (x-error-report-function condition) condition stream))
  1441.   condition)
  1442.   
  1443. #-lispm
  1444. (defun make-condition (type &rest slot-initializations)
  1445.   (let ((make-function (intern (concatenate 'string (string 'make-) (string type))
  1446.                    (symbol-package type))))
  1447.     (apply make-function slot-initializations)))
  1448.  
  1449. #-(or explorer genera)
  1450. (defun host-address (host &optional (family :internet))
  1451.   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  1452.   ;; and cdr is a list of network address bytes.
  1453.   (declare (type (or stringable list) host)
  1454.        (type (or null (member :internet :decnet :chaos) card8) family))
  1455.   (declare-values list)
  1456.   host family
  1457.   (error "HOST-ADDRESS not implemented yet."))
  1458.  
  1459. #+explorer
  1460. (defun host-address (host &optional (family :internet))
  1461.   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  1462.   ;; and cdr is a list of network address bytes.
  1463.   (declare (type (or stringable list) host)
  1464.        (type (or null (member :internet :decnet :chaos) card8) family))
  1465.   (declare-values list)
  1466.   (ecase family
  1467.     (:internet
  1468.      (let ((addr (ip:get-ip-address host)))
  1469.        (unless addr (error "~s isn't an internet host name" host))
  1470.        (list :internet
  1471.          (ldb (byte 8 24) addr)
  1472.          (ldb (byte 8 16) addr)
  1473.          (ldb (byte 8 8) addr)
  1474.          (ldb (byte 8 0) addr))))
  1475.     (:chaos
  1476.      (let ((addr (first (chaos:chaos-addresses host))))
  1477.        (unless addr (error "~s isn't a chaos host name" host))
  1478.        (list :chaos
  1479.          (ldb (byte 8 0) addr)
  1480.          (ldb (byte 8 8) addr))))))
  1481.  
  1482. #+genera
  1483. (defun host-address (host &optional (family :internet))
  1484.   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  1485.   ;; and cdr is a list of network address bytes.
  1486.   (declare (type (or stringable list) host)
  1487.        (type (or null (member :internet :decnet :chaos) card8) family))
  1488.   (declare-values list)
  1489.   (let ((net-type (if (eq family :DECnet)
  1490.               :DNA
  1491.               family)))
  1492.     (dolist (addr
  1493.           (sys:send (net:parse-host host) :network-addresses)
  1494.           (error "~s isn't a valid ~(~A~) host name" host family))
  1495.       (let ((network (car addr))
  1496.         (address (cadr addr)))
  1497.     (when (sys:send network :network-typep net-type)
  1498.       (return (ecase family
  1499.             (:internet
  1500.               (multiple-value-bind (a b c d) (tcp:explode-internet-address address)
  1501.             (list :internet a b c d)))
  1502.             ((:chaos :DECnet)
  1503.              (list family (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))
  1504.  
  1505. #+explorer ;; This isn't required, but it helps make sense of the results from access-hosts
  1506. (defun get-host (host-object)
  1507.   ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
  1508.   ;; and cdr is a list of network address bytes.
  1509.   (declare (type list host-object))
  1510.   (declare-values string family)
  1511.   (let* ((family (first host-object))
  1512.      (address (ecase family
  1513.             (:internet
  1514.              (dpb (second host-object)
  1515.               (byte 8 24)
  1516.               (dpb (third host-object)
  1517.                    (byte 8 16)
  1518.                    (dpb (fourth host-object)
  1519.                     (byte 8 8)
  1520.                     (fifth host-object)))))
  1521.             (:chaos
  1522.              (dpb (third host-object) (byte 8 8) (second host-object))))))
  1523.     (when (eq family :internet) (setq family :ip))
  1524.     (let ((host (si:get-host-from-address address family)))
  1525.       (values (and host (funcall host :name)) family))))
  1526.  
  1527. ;;; This isn't required, but it helps make sense of the results from access-hosts
  1528. #+genera
  1529. (defun get-host (host-object)
  1530.   ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
  1531.   ;; and cdr is a list of network address bytes.
  1532.   (declare (type list host-object))
  1533.   (declare-values string family)
  1534.   (let ((family (first host-object)))
  1535.     (values (sys:send (net:get-host-from-address 
  1536.             (ecase family
  1537.               (:internet
  1538.                 (apply #'tcp:build-internet-address (rest host-object)))
  1539.               ((:chaos :DECnet)
  1540.                (dpb (third host-object) (byte 8 8) (second host-object))))
  1541.             (net:local-network-of-type (if (eq family :DECnet)
  1542.                                :DNA
  1543.                                family)))
  1544.               :name)
  1545.         family)))
  1546.  
  1547. ;;; Printing routines.
  1548.  
  1549. #-lispm
  1550. (defun display-print (display stream depth)
  1551.   depth ;; not used
  1552.   (format stream "#<DISPLAY ~a ~d>"
  1553.       (display-host display)
  1554.       (display-display display)))
  1555.  
  1556. #+lispm
  1557. (defun display-print (display stream depth)
  1558.   depth ;; not used
  1559.   (si:printing-random-object (display stream :typep)
  1560.     (princ (display-host display) stream)
  1561.     (princ " " stream)
  1562.     (princ (display-display display) stream)))
  1563.